home *** CD-ROM | disk | FTP | other *** search
/ Celestin Apprentice 2 / Apprentice-Release2.iso / Tools / Languages / MacHaskell 2.2 / parser / parser-debugger.scm < prev    next >
Encoding:
Text File  |  1994-09-27  |  2.4 KB  |  82 lines  |  [TEXT/CCL2]
  1. ;;; These routines are strictly for debugging the parser.  They could
  2. ;;; be removed from the system later.
  3.  
  4. ;;; define some debugging stuff
  5. ;;;  Here's the debugging control:
  6. ;;;  Capabilities:
  7. ;;;      record start (line,token,production,k)
  8. ;;;      record end (line,token,prodection,k)
  9. ;;;      print end (line,token,prodection,k,value)
  10. ;;;      break start
  11. ;;;      break end
  12.  
  13. (define *parser-debug-options* '())
  14. (define *parser-debug-lines* '())
  15. (define *parser-debug-id* 0)
  16.  
  17. (define (watch-lines . lines)
  18.   (setf *parser-debug-lines* lines))
  19.  
  20. (define (watching-this-line?)
  21.  (and (not (eq? *parser-debug-lines* 'none))
  22.   (or (null? *parser-debug-lines*)
  23.       (and (>= *current-line* (car *parser-debug-lines*))
  24.        (or (null? (cdr *parser-debug-lines*))
  25.            (<= *current-line* (cadr *parser-debug-lines*)))))))
  26.  
  27. (define (ptrace-print-obj x)
  28.   (pprint x))
  29.  
  30. (define (ptrace-breakpoint)
  31.   (error "Breakpoint~%"))
  32.  
  33. (define (parser-show-context id tag msg)
  34.   (format '#t "~A parse of ~A(~A)  Line: ~A  Token: ~A"
  35.       msg tag id *current-line* *token*)
  36.   (when (not (null? *token-args*))
  37.      (format '#t " ~A" *token-args*))
  38.   (format '#t "~%"))
  39.  
  40. (define (ptrace-clear)
  41.   (setf *parser-debug-options* '()))
  42.  
  43. (define (ptrace-pop)
  44.   (pop *parser-debug-options*))
  45.  
  46. (define (ptrace-watch . things)
  47.   (dolist (x things)
  48.      (push (cons x 'watch) *parser-debug-options*)))
  49.  
  50. (define (ptrace-show . things)
  51.   (dolist (x things)
  52.      (push (cons x 'show) *parser-debug-options*)))
  53.  
  54. (define (ptrace-break . things)
  55.   (dolist (x things)
  56.      (push (cons x 'break) *parser-debug-options*)))
  57.  
  58. ;;; Routines called by the trace-parser macro
  59.  
  60. (define (tracing-parse/entry tag)
  61.   (let ((all? (assq 'all *parser-debug-options*))
  62.     (this? (assq tag *parser-debug-options*)))
  63.     (cond ((or all? this?)
  64.        (incf *parser-debug-id*)
  65.        (parser-show-context *parser-debug-id* tag "Entering")
  66.        (when (and this? (eq? (cdr this?) 'break))
  67.          (ptrace-breakpoint))
  68.        *parser-debug-id*)
  69.       (else 0))))
  70.  
  71. (define (tracing-parse/exit tag id res)
  72.   (let ((all? (assq 'all *parser-debug-options*))
  73.     (this? (assq tag *parser-debug-options*)))
  74.     (when (and (or all? this?) (not (eq? tag 0)))
  75.       (setf (dynamic *returned-obj*) res)
  76.       (parser-show-context id tag "Exiting")
  77.       (when (and this? (eq? (cdr this?) 'show))
  78.         (ptrace-print-obj res))
  79.       (when (and this? (eq? (cdr this?) 'break))
  80.         (ptrace-breakpoint)))))
  81.  
  82.